home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / MACROS2.LSP < prev    next >
Text File  |  1994-02-05  |  15KB  |  349 lines
  1. (in-package "SYSTEM")
  2. ;-------------------------------------------------------------------------------
  3. (defmacro typecase (keyform &rest typeclauselist)
  4.   (let* ((tempvar (gensym))
  5.          (condclauselist nil))
  6.     (do ((typeclauselistr typeclauselist (cdr typeclauselistr)))
  7.         ((atom typeclauselistr))
  8.       (cond ((atom (car typeclauselistr))
  9.              (error #+DEUTSCH "Unzulässige Klausel in ~S: ~S"
  10.                     #+ENGLISH "Invalid clause in ~S: ~S"
  11.                     #+FRANCAIS "Clause inadmissible dans ~S : ~S"
  12.                     'typecase (car typeclauselistr)
  13.             ))
  14.             ((let ((type (caar typeclauselistr)))
  15.                (or (eq type T) (eq type 'OTHERWISE))
  16.              )
  17.              (push `(T ,@(or (cdar typeclauselistr) '(NIL))) condclauselist)
  18.              (return)
  19.             )
  20.             (t (push `((TYPEP ,tempvar (QUOTE ,(caar typeclauselistr)))
  21.                        ,@(or (cdar typeclauselistr) '(NIL))
  22.                       )
  23.                      condclauselist
  24.             )  )
  25.     ) )
  26.     `(LET ((,tempvar ,keyform)) (COND ,@(nreverse condclauselist)))
  27. ) )
  28. ;-------------------------------------------------------------------------------
  29. (defmacro check-type (place typespec &optional (string nil))
  30.   (let ((tag1 (gensym))
  31.         (tag2 (gensym)))
  32.     `(TAGBODY
  33.        ,tag1
  34.        (WHEN (TYPEP ,place ',typespec) (GO ,tag2))
  35.        (CERROR #+DEUTSCH "Sie dürfen einen neuen Wert eingeben."
  36.                #+ENGLISH "You may input a new value."
  37.                #+FRANCAIS "Vous avez l'occasion d'entrer une nouvelle valeur."
  38.          #+DEUTSCH "~A~%Der Wert ist: ~S"
  39.          #+ENGLISH "~A~%The value is: ~S"
  40.          #+FRANCAIS "~A~%La valeur est : ~S"
  41.          ,(format nil #+DEUTSCH "Der Wert von ~S sollte ~:[vom Typ ~S~;~:*~A~] sein."
  42.                       #+ENGLISH "The value of ~S should be ~:[of type ~S~;~:*~A~]."
  43.                       #+FRANCAIS "La valeur de ~S devrait être ~:[de type ~S~;~:*~A~]."
  44.                       place string typespec
  45.           )
  46.          ,place
  47.        )
  48.        (WRITE-STRING
  49.          ,(format nil #+DEUTSCH "~%Neues ~S: "
  50.                       #+ENGLISH "~%New ~S: "
  51.                       #+FRANCAIS "~%Nouveau ~S : "
  52.                       place
  53.           )
  54.          *QUERY-IO*
  55.        )
  56.        (SETF ,place (READ *QUERY-IO*))
  57.        (GO ,tag1)
  58.        ,tag2
  59.      )
  60. ) )
  61. ;-------------------------------------------------------------------------------
  62. (defmacro assert (test-form &optional (place-list nil) (string nil) &rest args)
  63.   (let ((tag1 (gensym))
  64.         (tag2 (gensym)))
  65.     `(TAGBODY
  66.        ,tag1
  67.        (WHEN ,test-form (GO ,tag2))
  68.        (CERROR ,(case (length place-list)
  69.                   (0 #+DEUTSCH "Neuer Anlauf"
  70.                      #+ENGLISH "Retry"
  71.                      #+FRANCAIS "Reéssayer"
  72.                   )
  73.                   (1 #+DEUTSCH "Sie dürfen einen neuen Wert eingeben."
  74.                      #+ENGLISH "You may input a new value."
  75.                      #+FRANCAIS "Vous pouvez entrer une nouvelle valeur."
  76.                   )
  77.                   (t #+DEUTSCH "Sie dürfen neue Werte eingeben."
  78.                      #+ENGLISH "You may input new values."
  79.                      #+FRANCAIS "Vous pouvez entrer de nouvelles valeurs."
  80.                 ) )
  81.                ',(or string "~A")
  82.                ,@(if string
  83.                    args
  84.                    (list (format nil #+DEUTSCH "Der Wert von ~S darf nicht NIL sein."
  85.                                      #+ENGLISH "~S must evaluate to a non-NIL value."
  86.                                      #+FRANCAIS "La valeur de ~S ne peut pas être NIL."
  87.                                      test-form
  88.                  ) )     )
  89.        )
  90.        ,@(mapcan
  91.            #'(lambda (place)
  92.                (list `(WRITE-STRING
  93.                         ,(format nil #+DEUTSCH "~%Neues ~S: "
  94.                                      #+ENGLISH "~%New ~S: "
  95.                                      #+FRANCAIS "~%Nouveau ~S : "
  96.                                      place
  97.                          )
  98.                         *QUERY-IO*
  99.                       )
  100.                      `(SETF ,place (READ *QUERY-IO*))
  101.              ) )
  102.            place-list
  103.          )
  104.        (GO ,tag1)
  105.        ,tag2
  106.      )
  107. ) )
  108. ;-------------------------------------------------------------------------------
  109. (flet ((typecase-errorstring (keyform keyclauselist)
  110.          (format nil #+DEUTSCH "Der Wert von ~S muß einem der Typen ~{~S~^, ~} angehören."
  111.                      #+ENGLISH "The value of ~S must be of one of the types ~{~S~^, ~}"
  112.                      #+FRANCAIS "La valeur de ~S doit appartenir à l'un des types ~{~S~^, ~}."
  113.                      keyform (mapcar #'first keyclauselist)
  114.        ) )
  115.        (case-errorstring (keyform keyclauselist)
  116.          (format nil #+DEUTSCH "Der Wert von ~S muß einer der folgenden sein: ~{~S~^, ~}"
  117.                      #+ENGLISH "The value of ~S must be one of ~{~S~^, ~}"
  118.                      #+FRANCAIS "La valeur de ~S doit être l'une des suivantes : ~{~S~^, ~}"
  119.                      keyform
  120.                      (mapcap #'(lambda (keyclause)
  121.                                  (setq keyclause (car keyclause))
  122.                                  (if (listp keyclause) keyclause (list keyclause))
  123.                                )
  124.                              keyclauselist
  125.        ) )           )
  126.        (simple-error (casename form clauselist errorstring)
  127.          (let ((var (gensym)))
  128.            `(LET ((,var ,form))
  129.               (,casename ,var
  130.                 ,@clauselist
  131.                 (OTHERWISE
  132.                   (ERROR #+DEUTSCH "~A~%Der Wert ist: ~S"
  133.                          #+ENGLISH "~A~%The value is: ~S"
  134.                          #+FRANCAIS "~A~%La valeur est : ~S"
  135.                          ,errorstring ,var
  136.             ) ) ) )
  137.        ) )
  138.        (retry-loop (casename place clauselist errorstring)
  139.          (let ((g (gensym))
  140.                (h (gensym)))
  141.            `(BLOCK ,g
  142.               (TAGBODY
  143.                 ,h
  144.                 (RETURN-FROM ,g
  145.                   (,casename ,place
  146.                     ,@clauselist
  147.                     (OTHERWISE
  148.                       (CERROR #+DEUTSCH "Sie dürfen einen neuen Wert eingeben."
  149.                               #+ENGLISH "You may input a new value."
  150.                               #+FRANCAIS "Vous pouvez entrer une nouvelle valeur."
  151.                               #+DEUTSCH "~A~%Der Wert ist: ~S"
  152.                               #+ENGLISH "~A~%The value is: ~S"
  153.                               #+FRANCAIS "~A~%La valeur est : ~S"
  154.                               ,errorstring
  155.                               ,place
  156.                       )
  157.                       (WRITE-STRING
  158.                         ,(format nil #+DEUTSCH "~%Neues ~S: "
  159.                                      #+ENGLISH "~%New ~S: "
  160.                                      #+FRANCAIS "~%Nouveau ~S : "
  161.                                      place
  162.                          )
  163.                         *QUERY-IO*
  164.                       )
  165.                       (SETF ,place (READ *QUERY-IO*))
  166.                       (GO ,h)
  167.             ) ) ) ) )
  168.       )) )
  169.   (defmacro etypecase (keyform &rest keyclauselist)
  170.     (simple-error 'TYPECASE keyform keyclauselist
  171.                   (typecase-errorstring keyform keyclauselist)
  172.   ) )
  173.   (defmacro ctypecase (keyplace &rest keyclauselist)
  174.     (retry-loop 'TYPECASE keyplace keyclauselist
  175.                 (typecase-errorstring keyplace keyclauselist)
  176.   ) )
  177.   (defmacro ecase (keyform &rest keyclauselist)
  178.     (simple-error 'CASE keyform keyclauselist
  179.                   (case-errorstring keyform keyclauselist)
  180.   ) )
  181.   (defmacro ccase (keyform &rest keyclauselist)
  182.     (retry-loop 'CASE keyform keyclauselist
  183.                 (case-errorstring keyform keyclauselist)
  184.   ) )
  185. )
  186. ;-------------------------------------------------------------------------------
  187. (defmacro deftype (name lambdalist &body body &environment env)
  188.   (unless (symbolp name)
  189.     (error #+DEUTSCH "Typname muß ein Symbol sein, nicht ~S"
  190.            #+ENGLISH "type name should be a symbol, not ~S"
  191.            #+FRANCAIS "Le type doit être un symbole et non ~S"
  192.            name
  193.   ) )
  194.   (if (or (get name 'TYPE-SYMBOL) (get name 'TYPE-LIST))
  195.     (error #+DEUTSCH "~S ist ein eingebauter Typ und darf nicht umdefiniert werden."
  196.            #+ENGLISH "~S is a built-in type and may not be redefined."
  197.            #+FRANCAIS "~S est un type prédéfini et ne peut pas être redéfini."
  198.            name
  199.   ) )
  200.   (multiple-value-bind (body-rest declarations docstring)
  201.       (SYSTEM::PARSE-BODY body t env)
  202.     (if declarations (setq declarations (list (cons 'DECLARE declarations))))
  203.     (let ((%arg-count 0) (%min-args 0) (%restp nil)
  204.           (%let-list nil) (%keyword-tests nil) (%default-form '(QUOTE *)))
  205.       (analyze1 lambdalist '(CDR <DEFTYPE-FORM>) name '<DEFTYPE-FORM>)
  206.       (let ((lengthtest (make-length-test '<DEFTYPE-FORM>))
  207.             (mainform `(LET* ,(nreverse %let-list)
  208.                          ,@declarations
  209.                          ,@(nreverse %keyword-tests)
  210.                          ,@body-rest
  211.            ))          )
  212.         (if lengthtest
  213.           (setq mainform
  214.             `(IF ,lengthtest
  215.                (ERROR #+DEUTSCH "Der Deftype-Expander für ~S kann nicht mit ~S Argumenten aufgerufen werden."
  216.                       #+ENGLISH "The deftype expander for ~S may not be called with ~S arguments."
  217.                       #+FRANCAIS "L'«expandeur» de DEFTYPE pour ~S ne peut pas être appelé avec ~S arguments."
  218.                       ',name (1- (LENGTH <DEFTYPE-FORM>))
  219.                )
  220.                ,mainform
  221.         ) )  )
  222.         `(EVAL-WHEN (COMPILE LOAD EVAL)
  223.            (LET ()
  224.              (%PUT ',name 'DEFTYPE-EXPANDER
  225.                (FUNCTION ,(make-symbol (string-concat "DEFTYPE-" (string name)))
  226.                  (LAMBDA (<DEFTYPE-FORM>) ,mainform)
  227.              ) )
  228.              (SETF (DOCUMENTATION ',name 'TYPE) ',docstring)
  229.              ',name
  230.          ) )
  231. ) ) ) )
  232. ;-------------------------------------------------------------------------------
  233. (defmacro time (form)
  234.   (let ((vars (list (gensym) (gensym) (gensym) (gensym) (gensym) (gensym)
  235.                     (gensym) (gensym) (gensym)
  236.        ))     )
  237.     `(MULTIPLE-VALUE-BIND ,vars (%%TIME)
  238.        (UNWIND-PROTECT ,form (MULTIPLE-VALUE-CALL #'%TIME (%%TIME) ,@vars))
  239.      ) ; Diese Konstruktion verbraucht zur Laufzeit nur Stackplatz!
  240. ) )
  241. ;-------------------------------------------------------------------------------
  242. (defmacro with-input-from-string
  243.     ((var string &key (index nil sindex) (start '0 sstart) (end 'NIL send))
  244.      &body body &environment env)
  245.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  246.     (if declarations
  247.       (setq declarations (list (cons 'DECLARE declarations)))
  248.     )
  249.     `(LET ((,var (MAKE-STRING-INPUT-STREAM ,string
  250.                    ,@(if (or sstart send)
  251.                        `(,start ,@(if send `(,end) '()))
  252.                        '()
  253.           ))     )   )
  254.        ,@declarations
  255.        (UNWIND-PROTECT
  256.          (PROGN ,@body-rest)
  257.          ,@(if sindex `((SETF ,index (SYSTEM::STRING-INPUT-STREAM-INDEX ,var))) '())
  258.          (CLOSE ,var)
  259.      ) )
  260. ) )
  261. ;-------------------------------------------------------------------------------
  262. (defmacro with-open-file ((stream &rest options) &body body &environment env)
  263.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  264.     (if declarations
  265.       (setq declarations (list (cons 'DECLARE declarations)))
  266.     )
  267.     `(LET ((,stream (OPEN ,@options)))
  268.        ,@declarations
  269.        (UNWIND-PROTECT
  270.          (MULTIPLE-VALUE-PROG1 (PROGN ,@body-rest)
  271.            (WHEN ,stream (CLOSE ,stream))
  272.          )
  273.          (WHEN ,stream (CLOSE ,stream :ABORT T))
  274.      ) )
  275. ) )
  276. ;-------------------------------------------------------------------------------
  277. (defmacro with-open-stream ((var stream) &body body &environment env)
  278.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  279.     (if declarations
  280.       (setq declarations (list (cons 'DECLARE declarations)))
  281.     )
  282.     `(LET ((,var ,stream))
  283.        ,@declarations
  284.        (UNWIND-PROTECT
  285.          (MULTIPLE-VALUE-PROG1 (PROGN ,@body-rest) (CLOSE ,var))
  286.          (CLOSE ,var :ABORT T)
  287.      ) )
  288. ) )
  289. ;-------------------------------------------------------------------------------
  290. (defmacro with-output-to-string
  291.     ((var &optional (string nil sstring)) &body body &environment env)
  292.   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  293.     (if declarations
  294.       (setq declarations (list (cons 'DECLARE declarations)))
  295.     )
  296.     (if sstring
  297.       `(LET ((,var (SYS::MAKE-STRING-PUSH-STREAM ,string)))
  298.          ,@declarations
  299.          (UNWIND-PROTECT
  300.            (PROGN ,@body-rest)
  301.            (CLOSE ,var)
  302.        ) )
  303.       `(LET ((,var (MAKE-STRING-OUTPUT-STREAM)))
  304.          ,@declarations
  305.          (UNWIND-PROTECT
  306.            (PROGN ,@body-rest (GET-OUTPUT-STREAM-STRING ,var))
  307.            (CLOSE ,var)
  308.        ) )
  309. ) ) )
  310. ;-------------------------------------------------------------------------------
  311. (in-package "LISP")
  312. (export 'with-output-to-printer)
  313. (in-package "SYSTEM")
  314. (defmacro with-output-to-printer ((var) &body body &environment env)
  315.   #+ATARI
  316.     `(LET ((,var *PRINTER-OUTPUT*)) ,@body)
  317.   #-ATARI
  318.     (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body nil env)
  319.       (if declarations
  320.         (setq declarations (list (cons 'DECLARE declarations)))
  321.       )
  322.       #+VMS
  323.         (let ((filenamevar (gensym)))
  324.           `(LET (,filenamevar)
  325.              (WITH-OPEN-FILE (,var "SYS$SCRATCH:LISP_TO_PRINTER.TXT"
  326.                                    :DIRECTION :OUTPUT
  327.                                    :IF-EXISTS :NEW-VERSION
  328.                              )
  329.                ,@declarations
  330.                (SETQ ,filenamevar (TRUENAME ,var))
  331.                ,@body-rest
  332.              )
  333.              (SHELL (FORMAT NIL "PRINT /DELETE ~A" ,filenamevar))
  334.            )
  335.         )
  336.       #-VMS
  337.         `(LET ((,var #+UNIX (MAKE-PIPE-OUTPUT-STREAM "lpr")
  338.                      #-UNIX (SYS::MAKE-PRINTER-STREAM)
  339.               ))
  340.            ,@declarations
  341.            (UNWIND-PROTECT
  342.              (PROGN ,@body-rest)
  343.              (CLOSE ,var)
  344.          ) )
  345.     )
  346. )
  347. ;-------------------------------------------------------------------------------
  348.  
  349.